home *** CD-ROM | disk | FTP | other *** search
/ Acorn RISC PD-CD 1 / Acorn RISC PD-CD 1.iso / languages / _tile / f83 / structures < prev   
Encoding:
Text File  |  1991-08-11  |  4.6 KB  |  141 lines
  1. \
  2. \  STRUCTURE DEFINITIONS
  3. \
  4. \  Copyright (C) 1988-1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 30 June 1988
  15. \
  16. \  Last updated on: 3 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth
  20. \
  21. \  Description:
  22. \       Allows aggregates of data to be described as structures. General-
  23. \       ization of structures in traditional programming languages. Allows
  24. \       definition, initialization and action part. Basic object based
  25. \       action may be defined in a style similar to the "does" section of
  26. \       a creating word.
  27. \
  28. \  Copying:
  29. \       This program is free software; you can redistribute it and\or modify
  30. \       it under the terms of the GNU General Public License as published by
  31. \       the Free Software Foundation; either version 1, or (at your option)
  32. \       any later version.
  33. \
  34. \       This program is distributed in the hope that it will be useful,
  35. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  36. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  37. \       GNU General Public License for more details.
  38. \
  39. \       You should have received a copy of the GNU General Public License
  40. \       along with this program; see the file COPYING.  If not, write to
  41. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  42. vocabulary structures ( -- )
  43.  
  44. structures definitions 
  45.  
  46. 0 field +size ( struct.type -- addr) private
  47. cell field +initiate ( struct.type -- addr) private
  48.  
  49. : as ( -- struct.type)  
  50.   ' >body                              ( Quote next symbol and access body)
  51.   [compile] literal                    ( If compiling generate a literal)
  52. ; immediate                            
  53.  
  54. : this ( -- addr)
  55.   last >body                           ( Access the body of the last symbol)
  56. ;
  57.  
  58. : initiate ( addr struct.type -- )  
  59.   +initiate @ ?dup                     ( Access initiate. code pointer)
  60.   if >r else drop then                 ( If available perform initialization)
  61. ;
  62.  
  63. : make-struct ( struct.type -- addr)
  64.   here dup >r                          ( Save pointer to instance)
  65.   over +size @ allot                   ( Access size and allocate memory)
  66.   swap initiate r>                     ( Perform initialization)
  67. ; private
  68.  
  69. : new-struct ( -- addr)
  70.   [compile] as                                 ( Take the next symbol, "as")
  71.   ?compile make-struct                 ( And "make" an instance)
  72. ; immediate                            
  73.  
  74. : sizeof ( -- num)
  75.   ' >body +size @                      ( Access size of structure)
  76.   [compile] literal                    ( And make literal if compiling)
  77. ; immediate
  78.  
  79. : assign ( a b -- )  
  80.   [compile] sizeof ?compile cmove      ( Access size and assign instance)
  81. ; immediate
  82.  
  83. : not-equal ( a b -- bool)
  84.   [compile] sizeof ?compile -match     ( Access size and match the blocks)
  85. ; immediate
  86.  
  87. : struct.type ( -- struct.type offset0)  
  88.   create here 0 0 , 0 ,                ( Allocate initial struct information)
  89. does> ( struct.type -- )
  90.   create make-struct drop              ( Create a new instance)
  91. ;
  92.  
  93. : bytes ( offset1 n -- offset2)  
  94.   over dup                             ( Check for zero offset)
  95.   if field +                           ( Create an access field of "n" bytes)
  96.   else
  97.     create , + immediate               ( Create an efficient field)
  98.     does> ( field -- )
  99.       drop                             ( Does nothing at runtime )
  100.   then
  101. ;
  102.  
  103. : align ( offset1 -- offset2)  
  104.   dup 1 and +                          ( Align field offset to even address)
  105. ;
  106.  
  107. : struct.field ( bytes -- )  
  108.   create , nil ,                       ( Create a predefined field type)
  109. does> ( struct.field -- )
  110.   @ bytes                              ( At run-time create field names)
  111. ; private
  112.  
  113. : struct ( -- )  
  114.   [compile] sizeof bytes               ( Create a structure sized field name)
  115. ;
  116.  
  117. ( Initial set of field names)
  118. 1 struct.field byte ( -- )
  119. 2 struct.field word ( -- )
  120. 4 struct.field long ( -- )
  121. 4 struct.field ptr  ( -- )
  122. 4 struct.field enum ( -- )
  123.  
  124. : struct.init ( struct.type offset3 -- )
  125.   align over +size !                   ( Assign size of structure type)
  126.   here swap +initiate ! ]              ( And pointer to initialization code)
  127. ;
  128.  
  129. : struct.does ( -- ) 
  130.   [compile] does>                      ( Do what does-does)
  131. ; immediate compilation
  132.  
  133. : struct.end ( [] or [struct.type offset3] -- )  
  134.   compiling                            ( Check compilation status)
  135.   if [compile] ;                       ( If compiling then end definition)
  136.   else swap +size ! then               ( Else assign size of structure type)
  137. ; immediate
  138.  
  139. forth only
  140.  
  141.